﻿//faisal waris initial version
module FsBson
open System
open System.Text.RegularExpressions
open System.Text
open System.IO
open System.Globalization

let utf8Size (s:string) = System.Text.Encoding.UTF8.GetByteCount(s)
let stringSize s = 4 + (utf8Size s) + 1

type BinSubtype = Generic=0 | Function=1 | Old=2 | UUID=4 | MD5=5 | UserDefined=0x80

type Bson = 
    | BDoc of (string*Bson)list
    | BArr of Bson array
    | BStr of String
    | BSym of String
    | BDate of DateTime
    | BTimestamp of Int64
    | BFloat of float
    | BInt of int
    | BInt64 of Int64
    | BBool of bool
    | BRegex of string*string
    | BJS of string
    | BJSWS of string*Bson
    | BMinKey
    | BMaxKey
    | BOid of byte array
    | BBinary of BinSubtype*byte array
    | BNull
    | BDBPointer of string*byte array
    | BUndefined
    static member (?)(a, p) = 
        match a with
        | BDoc js ->
            let v = js |> List.tryFind (fun (k,_) -> k = p)
            match v with Some (_,p) -> p | None -> BNull
        | _ -> BNull
    member x.Val =
        match x with
        | BStr s -> s 
        | BSym s -> s
        | BFloat n -> n.ToString()
        | BInt n -> n.ToString()
        | BInt64 n -> n.ToString()
        | _ -> ""
    member x.ValF =
        match x with
        | BFloat n -> n
        | BInt n -> (float)n
        | BInt64 n -> (float)n
        | _ -> failwith "not a numeric value"
    member x.ValI =
        match x with
        | BInt n -> n
        | BFloat n -> Convert.ToInt32(n)
        | BInt64 n -> Convert.ToInt32(n)
        | _ -> failwith "not a numeric value"
    member x.ValI64 =
        match x with
        | BInt64 n -> n
        | BFloat n -> Convert.ToInt64(n)
        | BInt n -> Convert.ToInt64(n)
        | _ -> failwith "not a numeric value"
    member x.Item
        with get(index) =
            match x with
            | BArr arr -> arr.[index]
            | _ -> failwith "Bson object is not an array"
    member x.Count = match x with BArr arr -> arr.Length | BDoc m -> m.Length | _ -> 0
    member x.Names =
        match x with
        | BDoc m -> m |> List.map (fun (n,_) -> n)
        | x -> []
    member x.HasName k = 
        match x with
        | BDoc m -> m |> List.exists (fun (p,_) -> k=p)
        | _ -> false
    member x.isNotNull = match x with BNull -> false | _ -> true
    member x.isDocument = match x with BDoc _ -> true | _ -> false
    member x.isArray = match x with BArr _ -> true | _ -> false
    member x.ArrayVal = match x with BArr arr -> arr | _ -> failwith "bson value is not a bson array"
    member x.Map =
        match x with 
        | BDoc j ->  j |> Map.ofList
        | BJSWS (_,j) -> j.Map
        | _ -> failwith "bson value is not a bson document"
    member x.ByteSize =
        let tagField = 1
        let stringEnd = 1
        let int32SizeField = 4
        let docEnd = 1
        let docSize (m:List<string*Bson>) = (int32SizeField + docEnd,m) ||> List.fold (fun sz (k,v) -> sz + tagField + (utf8Size k) + stringEnd + v.ByteSize)
        match x with
        | BDoc m -> docSize m
        | BArr a -> 
            let mutable sz = int32SizeField + docEnd
            for i in 0..a.Length-1 do 
                let b = a.[i]
                let j:int =  if i=0 then 1 else i
                let iSize = (int)(Math.Floor(Math.Log10((float)j))) + 1
                sz <- sz + tagField + iSize + stringEnd + b.ByteSize 
            sz
        | BStr s -> stringSize s
        | BSym s -> stringSize s
        | BDate _ -> 8
        | BTimestamp _ -> 8
        | BFloat _ -> 8
        | BInt _ -> 4
        | BInt64 _ -> 8
        | BBool _ -> 1
        | BRegex (s1,s2) -> (utf8Size s1) + stringEnd + (utf8Size s2) + stringEnd
        | BJS s -> stringSize s
        | BJSWS (s,m) -> match m with BDoc _ -> int32SizeField + (stringSize s) + m.ByteSize | _ -> failwith "BJSWS (javascript with scope) should only contain a Bson of subtype BDoc"
        | BMinKey -> 0
        | BMaxKey -> 0
        | BOid b -> b.Length
        | BBinary (_,b) -> int32SizeField + 1 (*subtype*) + b.Length
        | BNull -> 0
        | BDBPointer (s,b) -> int32SizeField + (utf8Size s) + stringEnd + b.Length
        | BUndefined -> 0

let errorOut (str:BinaryReader) msg = failwithf "Expected %s at or around position %A" msg 0

let unixEpoch = DateTime(1970,1,1,0,0,0,DateTimeKind.Utc)

let rec bval (o:obj) =
    match o with
    | :? string as s -> BStr s
    | :? int as i -> BInt i
    | :? float as f -> BFloat f
    | :? DateTime as d -> BDate d
    | :? Int64 as i -> BInt64 i
    | :? (byte array) as bs -> BBinary (BinSubtype.Generic,bs)
    | :? bool as b -> BBool b
    | :? Bson as b -> b
    | :? ((string*#obj) seq) as d -> bson d
    | :? (obj seq) as os -> BArr [| for j in os -> bval j|]
    | o -> failwithf "Cannot convert value %A to bson - consider using an explict value using one of the BSon.xxx constructors" o
and bson (s:(string*#obj) seq) =
    s |> Seq.map (fun (k,v) -> k, bval v)
    |> Seq.toList
    |> BDoc

let rec (|BsonValue|) (str:BinaryReader) =
    match str.ReadByte() with
    |  0uy -> "\0\0\0",BNull,(str)
    |  1uy ->   match str with CString (str, Double (dbl, rest)) -> str,BFloat(dbl),rest
    |  2uy ->   match str with CString (str, String (v,rest)) -> str,BStr(v),rest
    |  3uy ->   match str with CString (str, Document(d,rest)) -> str,BDoc(d),rest
    |  4uy ->   match str with CString (str, Array(d,rest)) -> str,BArr(d),rest
    |  5uy ->   match str with CString (str, Binary((sb,b),rest)) -> str,BBinary(sb,b),rest
    |  6uy ->   match str with CString (str, rest) -> str,BUndefined,rest
    |  7uy ->   match str with CString (str, TwelveBytes (b,rest)) -> str,BOid(b),rest
    |  8uy ->   match str with CString (str, Bool (b, rest)) -> str,BBool(b),rest
    |  9uy ->   match str with CString (str, Date (d, rest)) -> str,BDate(d),rest
    | 0x0Auy -> match str with CString (str, rest) -> str,BNull,rest
    | 0x0Buy -> match str with CString (str, CString (reg, CString (opt, rest))) -> str,BRegex(reg,opt),rest
    | 0x0Cuy -> match str with CString (str, String(str2, TwelveBytes (b,rest))) -> str,BDBPointer(str2,b),rest
    | 0x0Duy -> match str with CString (str, String (js, rest)) -> str,BJS(js),rest
    | 0x0Euy -> match str with CString (str, String (sym, rest)) -> str,BSym(sym),rest
    | 0x0Fuy -> match str with CString (str, Int32 (_, String (js, Document(map, rest)))) -> str,BJSWS(js,BDoc(map)),rest
    | 0x10uy -> match str with CString (str, Int32 (i, rest)) -> str,BInt(i),rest
    | 0x11uy -> match str with CString (str, Int64 (i, rest)) -> str,BTimestamp(i),rest
    | 0x12uy -> match str with CString (str, Int64 (i,rest)) -> str, BInt64(i),rest
    | 0xFFuy -> match str with CString (str, rest) -> str,BMinKey,rest
    | 0x7Fuy -> match str with CString (str, rest) -> str,BMaxKey,rest
    | other -> sprintf "unknown type value %A" other |> errorOut str
    
and (|Date|) (str:BinaryReader) = 
    let v = str.ReadInt64()
    let dt = unixEpoch.AddMilliseconds(float v)
    dt,str
and (|Bool|) (str:BinaryReader) =str.ReadBoolean(),str
and (|TwelveBytes|) (str:BinaryReader) = str.ReadBytes(12),str
and (|Binary|) (str:BinaryReader) =
    let sz = str.ReadInt32()
    let subType =
        match byte(str.Read()) with
        | 0uy -> BinSubtype.Generic
        | 1uy -> BinSubtype.Function
        | 2uy -> BinSubtype.Old
        | 3uy -> BinSubtype.UUID
        | 4uy -> BinSubtype.MD5
        | 0x80uy -> BinSubtype.UserDefined
        | x -> sprintf "unknown binary subtype %A" x |> errorOut str
    (subType,str.ReadBytes(sz)),str
and (|Array|) (str:BinaryReader) =
    let sz = str.ReadInt32()
    let rec loop (s:BinaryReader) acc =
        match s with
        | BsonValue (name, b, rest) ->
            match name with
            | "\0\0\0" -> acc |> List.rev |> List.toArray,s
            | _ -> loop rest (b::acc)
    loop str []
and (|Document|) (str:BinaryReader) = 
    let sz = str.ReadInt32()
    let rec loop (s:BinaryReader) acc =
        match s with
        | BsonValue (name, b, rest) ->
            match name with
            | "\0\0\0" -> acc|>List.rev,s
            | _ -> loop rest ((name,b)::acc)
    loop str []
and (|Double|) (str:BinaryReader) = str.ReadDouble(),str
and (|Int64|) (str:BinaryReader) = str.ReadInt64(),str
and (|Int32|) (str:BinaryReader) = str.ReadInt32(),str
and (|CString|) (str:BinaryReader) = 
    use ms = new MemoryStream(100)
    let mutable b = str.ReadByte()
    while b <> 0uy do ms.WriteByte(b); b <- str.ReadByte()
    let s = System.Text.Encoding.UTF8.GetString(ms.GetBuffer(),0,int(ms.Position))
    s,str
and (|String|) (str:BinaryReader) = 
    let sz = str.ReadInt32() - 1
    let bytes = str.ReadBytes(sz)
    let s = System.Text.Encoding.UTF8.GetString(bytes)
    str.ReadByte() |> ignore
    s,str

let bsonTag b =
    match b with
    | BFloat _ ->   0x01uy
    | BStr _ ->     0x02uy
    | BDoc _ ->     0x03uy
    | BArr _ ->     0x04uy
    | BBinary _ ->  0x05uy
    | BUndefined -> 0x06uy
    | BOid _ -> 0x07uy
    | BBool _ ->    0x08uy
    | BDate _ ->    0x09uy
    | BNull ->      0x0Auy
    | BRegex _ ->   0x0Buy
    | BDBPointer _ -> 0x0Cuy
    | BJS _ ->      0x0Duy
    | BSym _ ->     0x0Euy
    | BJSWS _ ->    0x0Fuy
    | BInt _ ->     0x10uy
    | BTimestamp _ -> 0x11uy
    | BInt64 _ ->   0x12uy
    | BMinKey ->    0xFFuy
    | BMaxKey ->    0x7Fuy

//let writeInt (str:Stream) (i:int)  = 
//    str.WriteByte((byte)i)
//    str.WriteByte((byte)(i>>>8))
//    str.WriteByte((byte)(i>>>16))
//    str.WriteByte((byte)(i>>>24))
//
//let writeInt64 (str:Stream) (i:Int64) =
//    str.WriteByte((byte)i)
//    str.WriteByte((byte)(i>>>8))
//    str.WriteByte((byte)(i>>>16))
//    str.WriteByte((byte)(i>>>24))
//    str.WriteByte((byte)(i>>>32))
//    str.WriteByte((byte)(i>>>40))
//    str.WriteByte((byte)(i>>>48))
//    str.WriteByte((byte)(i>>>56))

let writeCString (str:BinaryWriter) (s:string) =
    let utf = System.Text.Encoding.UTF8.GetBytes(s)
    str.Write(utf,0,utf.Length)
    str.Write(0uy)

let writeString (str:BinaryWriter) (s:string) =
    let utf = System.Text.Encoding.UTF8.GetBytes(s)
    str.Write(utf.Length + 1)
    str.Write(utf,0,utf.Length)
    str.Write(0uy)

let rec serializeBson b (str:BinaryWriter) =

    let serializeMap (m:List<String*Bson>) =
        m |> List.iter(fun (k,v) -> 
           str.Write(bsonTag v)
           writeCString str k
           serializeBson v str)

    match b with
    | BDoc m -> str.Write(b.ByteSize); serializeMap(m); str.Write(0uy)
    | BArr a -> 
        str.Write(b.ByteSize)
        a|>Array.iteri(fun i b -> str.Write(bsonTag b); writeCString str (i.ToString()); serializeBson b str)
        str.Write(0uy)
    | BStr s -> writeString str s
    | BSym s -> writeString str s
    | BDate d -> 
        let ts = d - unixEpoch
        let i = Convert.ToInt64(ts.TotalMilliseconds)
        str.Write(i)
    | BTimestamp ts -> str.Write(ts)
    | BFloat fl -> str.Write(fl)
    | BInt i -> str.Write(i)
    | BInt64 i -> str.Write(i)
    | BBool t -> str.Write(t)
    | BRegex (s1,s2) -> writeCString str s1; writeCString str s2 
    | BJS s -> writeString str s
    | BJSWS (s,m) ->
        let bjswsSize = (stringSize s) + m.ByteSize
        str.Write(bjswsSize); writeString str s; serializeBson m str
    | BMinKey -> ()
    | BMaxKey -> ()
    | BOid b -> str.Write(b,0,b.Length)
    | BBinary (sb,b) -> str.Write(b.Length); str.Write((byte)sb); str.Write(b)
    | BNull -> ()
    | BDBPointer (s,b) -> writeString str s; str.Write(b)
    | BUndefined -> ()
